home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / Modes / HTML and CSS Modes / htmlValidate.tcl < prev    next >
Encoding:
Text File  |  2001-01-13  |  29.7 KB  |  835 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  HTML mode - tools for editing HTML documents
  4.  # 
  5.  #  FILE: "htmlValidate.tcl"
  6.  #                                    created: 99-07-20 17.44.41 
  7.  #                                last update: 01-01-13 12.50.22 
  8.  #  Author: Johan Linde
  9.  #  E-mail: <alpha_www_tools@go.to>
  10.  #     www: <http://go.to/alpha_www_tools>
  11.  #  
  12.  # Version: 3.0
  13.  # 
  14.  # Copyright 1996-2001 by Johan Linde
  15.  #  
  16.  # This program is free software; you can redistribute it and/or modify
  17.  # it under the terms of the GNU General Public License as published by
  18.  # the Free Software Foundation; either version 2 of the License, or
  19.  # (at your option) any later version.
  20.  # 
  21.  # This program is distributed in the hope that it will be useful,
  22.  # but WITHOUT ANY WARRANTY; without even the implied warranty of
  23.  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24.  # GNU General Public License for more details.
  25.  # 
  26.  # You should have received a copy of the GNU General Public License
  27.  # along with this program; if not, write to the Free Software
  28.  # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  29.  # 
  30.  # ###################################################################
  31.  ##
  32.  
  33. #===============================================================================
  34. # This file contains procs for validating HTML documents.
  35. #===============================================================================
  36.  
  37. #===============================================================================
  38. # ◊◊◊◊ Validation ◊◊◊◊ #
  39. #===============================================================================
  40.  
  41. proc html::FindUnbalancedTags {} {
  42.     global tileLeft tileTop tileWidth errorHeight html::OptionalClosingTags html::EmptyElems
  43.     
  44.     message "Searching for unbalanced tags…"
  45.     set fil [html::StrippedFrontWindowPath]
  46.     # These may not have an closing tag.
  47.     set empty ${html::EmptyElems}
  48.     lappend empty !DOCTYPE SPACER WBR EMBED BGSOUND KEYGEN
  49.     # These have an optional closing tag.
  50.     set closingOptional ${html::OptionalClosingTags}
  51.     lappend closingOptional HEAD BODY HTML WINDOW
  52.     # These have an optional opening tag.
  53.     set openingOptional {HTML HEAD BODY TBODY}
  54.     
  55.     set tagStack WINDOW
  56.     set pos [minPos]
  57.     while {![catch {search -s -f 1 -r 1 -i 1 -m 0 {<!--|<[^<>]+>} $pos} res]} {
  58.         set tagstart [lindex $res 0]
  59.         set tagend   [lindex $res 1]
  60.         set tagtxt [getText $tagstart $tagend]
  61.         if {$tagtxt == "<!--"} {
  62.             # Comment
  63.             if {![catch {search -s -f 1 -r 0 -m 0 -- {-->} $tagstart} res]} {
  64.                 set pos [lindex $res 1]
  65.             } else {
  66.                 set pos [maxPos]
  67.             }
  68.             continue
  69.         }
  70.         # get element name
  71.         if {![regexp {<([^ \t\r\n>]+)} $tagtxt tmp tag]} {
  72.             append errtxt "Line [lindex [posToRowCol $tagstart] 0]: No element name in tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  73.             set pos $tagend
  74.             continue
  75.         }
  76.         set tag [string toupper $tag]
  77.         # is this a closing tag?
  78.         if {[string index $tag 0] == "/"} {
  79.             set tag [string range $tag 1 end]
  80.             if {[lsearch -exact $empty $tag] >= 0} {
  81.                 append errtxt "Line [lindex [posToRowCol $tagstart] 0]: $tag may mot have a closing tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  82.             } elseif {[lsearch -exact $tagStack $tag] < 0 && [lsearch -exact $openingOptional $tag] < 0} {
  83.                 append errtxt "Line [lindex [posToRowCol $tagstart] 0]: Closing $tag tag without a matching opening tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  84.             } else {
  85.                 for {set i 0} {$i < [llength $tagStack]} {incr i} {
  86.                     if {[set this [lindex $tagStack $i]] != $tag} {
  87.                         if {[lsearch -exact $closingOptional $this] < 0} {
  88.                             append errtxt "Line [lindex [posToRowCol $tagstart] 0]: $this must be closed before $tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  89.                         }
  90.                     } else {
  91.                         break
  92.                     }
  93.                 }
  94.                 set tagStack [lrange $tagStack [expr {$i + 1}] end]
  95.             }
  96.         } else {
  97.             # opening tag
  98.             if {[lsearch -exact $empty $tag] < 0} {
  99.                 set tagStack [concat $tag $tagStack]
  100.             }
  101.         }
  102.         set pos $tagend
  103.     }
  104.     # check if there are unclosed tags.
  105.     for {set i 0} {$i < [llength $tagStack]} {incr i} {
  106.         if {[lsearch -exact $closingOptional [set this [lindex $tagStack $i]]] < 0} {
  107.             append errtxt "Line [lindex [posToRowCol [maxPos]] 0] : $this must be closed before HTML.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  108.         }
  109.     }
  110.     if {[info exists errtxt]} {
  111.         new -n "* Errors *" -g $tileLeft $tileTop $tileWidth $errorHeight -m Brws
  112.         insertText "Errors:  (<uparrow> and <downarrow> to browse, <return> to go to file)\r\r"
  113.         insertText $errtxt
  114.         html::SetWin
  115.     } else {
  116.         alertnote "No unbalanced tags found!"
  117.     }
  118.  
  119. }
  120.  
  121. proc html::CheckTagsandAttributes {} {
  122.     html::CheckTags 1
  123. }
  124.  
  125. proc html::CheckTags {{attributes 0}} {
  126.     global tileLeft tileTop tileWidth errorHeight html::ElemMayContain html::OptionalClosingTags html::EmptyElems
  127.     global html::ElemMayContainLoose html::ElemMayContainStrict html::ElemMayContainFrame html::CommentRegexp html::NotInStrict
  128.     message "Checking tags…"
  129.     set fil [html::StrippedFrontWindowPath]
  130.     
  131.     # These have an optional closing tag.
  132.     set closingOptional ${html::OptionalClosingTags}
  133.     lappend closingOptional HEAD BODY HTML WINDOW
  134.     set doctype [html::FindDoctype]
  135.     if {$doctype == "" && ![catch {search -s -f 1 -r 1 -i 1 -m 0 {<frameset[^<>]+>} [minPos]}]} {
  136.         set doctype "frameset"
  137.     }
  138.     if {$doctype == ""} {set doctype "transitional"}
  139.     # Make some things unknown depending on the doctype.
  140.     if {$doctype == "strict"} {
  141.         foreach elem [array names html::ElemMayContainStrict] {
  142.             set html::ElemMayContain($elem) [set html::ElemMayContainStrict($elem)]
  143.         }
  144.     }
  145.     if {$doctype == "transitional"} {
  146.         foreach elem [array names html::ElemMayContainLoose] {
  147.             set html::ElemMayContain($elem) [set html::ElemMayContainLoose($elem)]
  148.         }
  149.     } 
  150.     if {$doctype == "frameset"} {
  151.         foreach elem [array names html::ElemMayContainFrame] {
  152.             set html::ElemMayContain($elem) [set html::ElemMayContainFrame($elem)]
  153.         }
  154.     } 
  155.     # Validate
  156.     set nr 0
  157.     set tagName(0) WINDOW
  158.     set tagContent(0) ""
  159.     set pos [minPos]
  160.     while {![catch {search -s -f 1 -r 1 -i 1 -m 0 {<!--|<[^<>]+>} $pos} res]} {
  161.         set tagstart [lindex $res 0]
  162.         set tagend   [lindex $res 1]
  163.         set tagtxt [getText $tagstart $tagend]
  164.         set line "Line [lindex [posToRowCol $tagstart] 0]:"
  165.         # get element name
  166.         set tag ""
  167.         if {$tagtxt != "<!--" && ![regexp {<([^ \t\r\n>]+)} $tagtxt "" tag]} {
  168.             append errtxt "$line No element name in tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  169.             set pos $tagend
  170.             continue
  171.         } else {
  172.             set tag [string toupper $tag]
  173.         }
  174.         if {[pos::compare $tagstart > $pos]} {
  175.             set prevTxt [getText $pos $tagstart]
  176.         } else {
  177.             set prevTxt ""
  178.         }
  179.         # check for unmatched < in text.
  180.         if {[regexp {<} $prevTxt]} {
  181.             append errtxt "$line Unmatched <.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  182.         }
  183.         # Check if there is text before the tag.
  184.         if {![regexp {^[ \t\r\n]*$} $prevTxt]} {
  185.             lappend tagContent($nr) text
  186.             set err ""
  187.             html::CheckContent tagName tagContent nr err text
  188.             foreach e $err {
  189.                 append errtxt "$line $e\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  190.             }
  191.         }
  192.         if {$tagtxt == "<!--"} {
  193.             # Comment
  194.             if {![catch {search -s -f 1 -r 0 -m 0 -- {-->} $tagstart} res]} {
  195.                 set pos [lindex $res 1]
  196.             } else {
  197.                 set pos [maxPos]
  198.             }
  199.             continue
  200.         }
  201.         # Silently ignore !DOCTYPE
  202.         if {$tag == "!DOCTYPE"} {
  203.             set pos $tagend
  204.             continue
  205.         }
  206.         set xtag [string trimleft $tag /]
  207.         if {![info exists html::ElemMayContain($xtag)] && [lsearch -exact ${html::EmptyElems} $xtag] < 0} {
  208.             # Unknown tag?
  209.             append errtxt "$line $xtag is unknown.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  210.         } elseif {[lsearch -exact ${html::NotInStrict} $xtag] >= 0 && $doctype == "strict"} {
  211.             append errtxt "$line $xtag may not be used with the strict DTD.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"        
  212.         } elseif {[string index $tag 0] == "/"} {
  213.             # Closing tag
  214.             set tag [string range $tag 1 end]
  215.             # Empty element?
  216.             if {[lsearch -exact ${html::EmptyElems} $tag] >= 0} {
  217.                 append errtxt "$line $tag may mot have a closing tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  218.             }
  219.             while {1} {
  220.                 if {$tag == $tagName($nr)} {
  221.                     set err ""
  222.                     html::PopTag tagName tagContent nr err
  223.                     foreach e $err {
  224.                         append errtxt "$line $e\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  225.                     }                    
  226.                     break
  227.                 }
  228.                 # Closing without matching opening?
  229.                 if {[lsearch -exact [array get tagName] $tag] < 0} {
  230.                     append errtxt "$line Closing $tag tag without a matching opening tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  231.                     break
  232.                 }
  233.                 # Silently close those with an optional closing tag.                
  234.                 if {[lsearch -exact $closingOptional $tagName($nr)] < 0} {
  235.                     append errtxt "$line $tagName($nr) must be closed before $tag.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  236.                 }
  237.                 set err ""
  238.                 html::PopTag tagName tagContent nr err
  239.                 foreach e $err {
  240.                     append errtxt "$line $e\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  241.                 }                    
  242.             }
  243.             # check if there's anything after </HTML>
  244.             if {$tag == "HTML"} {
  245.                 regsub -all ${html::CommentRegexp} [getText $tagend [maxPos]] "" ending
  246.                 if {![is::Whitespace $ending]} {
  247.                     append errtxt "$line Text after </HTML>.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  248.                 }
  249.                 break
  250.             }
  251.         } else {
  252.             # Opening tag
  253.             if {$attributes} {
  254.                 set err ""
  255.                 html::CheckAttributes $tag [string trimleft $tagtxt "< "] err $tagstart $doctype
  256.                 foreach e $err {
  257.                     append errtxt "$line $e\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  258.                 }
  259.             }
  260.             lappend tagContent($nr) $tag
  261.             set err ""
  262.             html::CheckContent tagName tagContent nr err $tag
  263.             html::PushTag $tag tagName tagContent nr err
  264.             foreach e $err {
  265.                 append errtxt "$line $e\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  266.             }
  267.             # Content of SCRIPT and STYLE end by </
  268.             if {$tag == "SCRIPT" || $tag == "STYLE"} {
  269.                 if {![catch {search -s -f 1 -r 0 -m 0 {</} $tagend} res]} {
  270.                     set tagend [lindex $res 0]
  271.                 } else {
  272.                     set tagend [maxPos]
  273.                 }
  274.             }
  275.         }
  276.         set pos $tagend
  277.     }
  278.     # check if there are unclosed tags.
  279.     while {$nr > 0} {
  280.         if {[lsearch -exact $closingOptional $tagName($nr)] < 0} {
  281.             append errtxt "$line $tagName($nr) must be closed before HTML.\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  282.         }
  283.         set err ""
  284.         html::PopTag tagName tagContent nr err
  285.         foreach e $err {
  286.             append errtxt "$line $e\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fil\r"
  287.         }                    
  288.     }
  289.     if {[info exists errtxt]} {
  290.         new -n "* Errors *" -g $tileLeft $tileTop $tileWidth $errorHeight -m Brws
  291.         insertText "Errors:  (<uparrow> and <downarrow> to browse, <return> to go to line)\r\r"
  292.         insertText $errtxt
  293.         html::SetWin
  294.     } else {
  295.         alertnote "No syntax errors found!"
  296.     }
  297.     
  298. }
  299.  
  300. proc html::CheckContent {name content n e tag {dontclosetbody 0}} {
  301.     upvar $name tagName $content tagContent $n nr $e err
  302.     global html::ElemMayContain html::OptionalClosingTags html::NestRestrictTags html::NestingRestriction
  303.     
  304.     # Is nesting of tag ok?
  305.     if {[lsearch -exact  ${html::NestRestrictTags} $tag] >= 0 && [regexp " [join [set html::NestingRestriction($tag)] |] " " [array get tagName] " t]} {
  306.         lappend err "$tag may not appear anywhere inside [string trim $t]."
  307.     }
  308.     
  309.     # May tag be here?
  310.     if {[lsearch -exact [set html::ElemMayContain($tagName($nr))] $tag] >= 0} {return}
  311.     
  312.     # Insert TBODY in TABLE if possible.
  313.     if {$tagName($nr) == "TABLE"} {
  314.         set tagContent($nr) [lreplace $tagContent($nr) end end]
  315.         lappend tagContent($nr) TBODY
  316.         html::PushTag TBODY tagName tagContent nr err
  317.         lappend tagContent($nr) $tag
  318.         html::CheckContent tagName tagContent nr err $tag 1
  319.         return
  320.     }
  321.     # Insert HEAD or BODY in HTML if possible.
  322.     if {$tagName($nr) == "HTML"} {
  323.         if {$tagContent($nr) == $tag} {
  324.             set tagContent($nr) HEAD
  325.             html::PushTag HEAD tagName tagContent nr err
  326.             lappend tagContent($nr) $tag
  327.             html::CheckContent tagName tagContent nr err $tag
  328.             return
  329.         } elseif {[lrange $tagContent($nr) [expr {[llength $tagContent($nr)] - 2}] end] == [list HEAD $tag] && [lcontains html::ElemMayContain(HTML) BODY]} {
  330.             set tagContent($nr) [lreplace $tagContent($nr) end end BODY]
  331.             html::PushTag BODY tagName tagContent nr err
  332.             lappend tagContent($nr) $tag
  333.             html::CheckContent tagName tagContent nr err $tag
  334.             return
  335.         }
  336.     }
  337.     # Insert BODY in NOFRAMES if possible.
  338.     if {$tagName($nr) == "NOFRAMES" && [set html::ElemMayContain(NOFRAMES)] == "BODY" && $tagContent($nr) == $tag} {
  339.         set tagContent($nr) BODY
  340.         html::PushTag BODY tagName tagContent nr err
  341.         lappend tagContent($nr) $tag
  342.         html::CheckContent tagName tagContent nr err $tag
  343.         return
  344.     }
  345.     
  346.     # Insert HTML if possible.
  347.     if {$tagName($nr) == "WINDOW" && $tagContent($nr) == $tag} {
  348.         set tagContent($nr) HTML
  349.         html::PushTag HTML tagName tagContent nr err
  350.         lappend tagContent($nr) $tag
  351.         html::CheckContent tagName tagContent nr err $tag
  352.         return
  353.     }
  354.     # Implicitely insert optional closing tags.
  355.     if {([lsearch -exact ${html::OptionalClosingTags} $tagName($nr)] >= 0 && !($tagName($nr) == "TBODY" && $dontclosetbody)) || $tagName($nr) == "HEAD"} {
  356.         set tagContent($nr) [lreplace $tagContent($nr) end end]
  357.         html::PopTag tagName tagContent nr err
  358.         lappend tagContent($nr) $tag
  359.         html::CheckContent tagName tagContent nr err $tag
  360.         return
  361.     } else {
  362.         lappend err "$tagName($nr) may not contain $tag."
  363.     }
  364. }
  365.  
  366. proc html::PushTag {tag name content n e} {
  367.     upvar $name tagName $content tagContent $n nr $e err
  368.     global html::EmptyElems
  369.     if {[info commands html::MustNotContainCheck$tagName($nr)] != "" || [info commands ::html::MustNotContainCheck$tagName($nr)] != ""} {
  370.         html::MustNotContainCheck$tagName($nr) $tagContent($nr) $tag err
  371.     }
  372.     if {[lsearch -exact ${html::EmptyElems} $tag] < 0} {
  373.         incr nr
  374.         set tagName($nr) $tag
  375.         set tagContent($nr) ""
  376.     }
  377. }
  378.  
  379. proc html::PopTag {name content n e} {
  380.     upvar $name tagName $content tagContent $n nr $e err
  381.     if {[info commands html::MustContainCheck$tagName($nr)] != "" || [info commands ::html::MustContainCheck$tagName($nr)] != ""} {
  382.         html::MustContainCheck$tagName($nr) $tagContent($nr) err
  383.     }
  384.     unset tagName($nr)
  385.     unset tagContent($nr)
  386.     incr nr -1
  387. }
  388.  
  389. proc html::MustContainCheckBLOCKQUOTE {content e} {
  390.     upvar $e err
  391.     global html::ElemMayContain html::ElemMayContainLoose
  392.     if {[set html::ElemMayContain(BLOCKQUOTE)] == [set html::ElemMayContainLoose(BLOCKQUOTE)]} {return}
  393.     if {$content == ""} {lappend err "BLOCKQUOTE must contain at least one block-level or SCRIPT element."}    
  394. }
  395.  
  396. proc html::MustContainCheckBODY {content e} {
  397.     upvar $e err
  398.     global html::ElemMayContain html::ElemMayContainLoose
  399.     if {[set html::ElemMayContain(BODY)] == [set html::ElemMayContainLoose(BODY)]} {return}
  400.     if {$content == ""} {lappend err "BODY must contain at least one block-level or SCRIPT element."}    
  401. }
  402.  
  403. proc html::MustContainCheckDIR {content e} {
  404.     upvar $e err
  405.     if {$content == ""} {lappend err "DIR must contain at least one LI element."}
  406. }
  407.  
  408. proc html::MustContainCheckMENU {content e} {
  409.     upvar $e err
  410.     if {$content == ""} {lappend err "MENU must contain at least one LI element."}
  411. }
  412.  
  413. proc html::MustContainCheckDL {content e} {
  414.     upvar $e err
  415.     if {$content == ""} {lappend err "DL must contain at least one DT or DD element."}
  416. }
  417.  
  418. proc html::MustContainCheckFIELDSET {content e} {
  419.     upvar $e err
  420.     if {$content == ""} {lappend err "FIELDSET must contain a LEGEND element."}
  421. }
  422.  
  423. proc html::MustNotContainCheckFIELDSET {content tag e} {
  424.     upvar $e err
  425.     if {$tag == "LEGEND" && [regsub -all "LEGEND" $content "" ""] > 1} {lappend err "FIELDSET may only contain one LEGEND element."}
  426.     if {$tag != "LEGEND" && $content == $tag} {lappend err "LEGEND must be the first element inside FIELDSET."}
  427. }
  428.  
  429. proc html::MustContainCheckFORM {content e} {
  430.     upvar $e err
  431.     global html::ElemMayContain html::ElemMayContainLoose
  432.     if {[set html::ElemMayContain(FORM)] == [set html::ElemMayContainLoose(FORM)]} {return}
  433.     if {$content == ""} {lappend err "FORM must contain at least one block-level or SCRIPT element."}    
  434. }
  435.  
  436. proc html::MustContainCheckFRAMESET {content e} {
  437.     upvar $e err
  438.     if {[lsearch -exact $content FRAME] < 0 && [lsearch -exact $content FRAMESET] < 0} {lappend err "FRAMESET must contain at least one FRAME or FRAMESET element."}
  439. }
  440.  
  441. proc html::MustNotContainCheckFRAMESET {content tag e} {
  442.     upvar $e err
  443.     if {$tag == "NOFRAMES" && [regsub -all "NOFRAMES" $content "" ""] > 1} {lappend err "FRAMESET may only contain one NOFRAMES element."}    
  444. }
  445.  
  446. proc html::MustContainCheckHEAD {content e} {
  447.     upvar $e err
  448.     if {[lsearch -exact $content TITLE] < 0} {lappend err "HEAD must contain a TITLE element."}
  449. }
  450.  
  451. proc html::MustNotContainCheckHEAD {content tag e} {
  452.     upvar $e err
  453.     if {$tag == "BASE" && [regsub -all "BASE" $content "" ""] > 1} {lappend err "HEAD may only contain one BASE element."}
  454.     if {$tag == "ISINDEX" && [regsub -all "ISINDEX" $content "" ""] > 1} {lappend err "HEAD may only contain one ISINDEX element."}
  455.     if {$tag == "TITLE" && [regsub -all "TITLE" $content "" ""] > 1} {lappend err "HEAD may only contain one TITLE element."}
  456. }
  457.  
  458. proc html::MustContainCheckHTML {content e} {
  459.     upvar $e err
  460.     global html::ElemMayContain html::ElemMayContainFrame
  461.     if {[set html::ElemMayContain(HTML)] == [set html::ElemMayContainFrame(HTML)] &&
  462.     ![regsub -all "FRAMESET" $content "" ""]} {
  463.         lappend err "HTML must contain a FRAMESET element."
  464.     }
  465. }
  466.  
  467. proc html::MustNotContainCheckHTML {content tag e} {
  468.     upvar $e err
  469.     global html::ElemMayContain html::ElemMayContainFrame
  470.     if {$tag == "HEAD" && [regsub -all "HEAD" $content "" ""] > 1} {lappend err "HTML may only contain one HEAD element."}
  471.     if {$tag == "BODY" && [set html::ElemMayContain(HTML)] != [set html::ElemMayContainFrame(HTML)] && 
  472.     [regsub -all "BODY" $content "" ""] > 1} {lappend err "HTML may only contain one BODY element."}
  473.     if {$tag == "FRAMESET" && [set html::ElemMayContain(HTML)] == [set html::ElemMayContainFrame(HTML)] && 
  474.     [regsub -all "FRAMESET" $content "" ""] > 1} {lappend err "HTML may only contain one FRAMESET element."}
  475. }
  476.  
  477. proc html::MustContainCheckMAP {content e} {
  478.     upvar $e err
  479.     if {$content == ""} {lappend err "MAP must contain at least one block-level or AREA element."}
  480. }
  481.  
  482. proc html::MustContainCheckNOSCRIPT {content e} {
  483.     upvar $e err
  484.     global html::ElemMayContain html::ElemMayContainLoose
  485.     if {[set html::ElemMayContain(NOSCRIPT)] == [set html::ElemMayContainLoose(NOSCRIPT)]} {return}
  486.     if {$content == ""} {lappend err "NOSCRIPT must contain at least one block-level element."}    
  487. }
  488.  
  489. proc html::MustContainCheckOL {content e} {
  490.     upvar $e err
  491.     if {$content == ""} {lappend err "OL must contain at least one LI element."}
  492. }
  493.  
  494. proc html::MustContainCheckOPTGROUP {content e} {
  495.     upvar $e err
  496.     if {$content == ""} {lappend err "OPTGROUP must contain at least one OPTION element."}
  497. }
  498.  
  499. proc html::MustContainCheckSELECT {content e} {
  500.     upvar $e err
  501.     if {$content == ""} {lappend err "SELECT must contain at least one OPTGROUP or OPTION element."}
  502. }
  503.  
  504. proc html::MustContainCheckTABLE {content e} {
  505.     upvar $e err
  506.     if {![regsub "TBODY" $content "" ""]} {lappend err "TABLE must contain at least one TBODY element."}    
  507. }
  508.  
  509. proc html::MustNotContainCheckTABLE {content tag e} {
  510.     upvar $e err
  511.     switch -- $tag {
  512.         CAPTION {
  513.             if {[regsub -all "CAPTION" $content "" ""] > 1} {
  514.                 lappend err "TABLE may only contain one CAPTION element."
  515.             } elseif {[llength $content] > 1} {
  516.                 lappend err "CAPTION must be the first element inside TABLE."
  517.             }
  518.         }
  519.         COL -
  520.         COLGROUP {
  521.             if {$tag == "COL" && [regsub "COLGROUP" $content "" ""] ||
  522.             $tag == "COLGROUP" && [regsub "COL " $content " " ""]} {
  523.                 lappend err "TABLE may not contain both COL and COLGROUP elements."
  524.             }
  525.             if {[regsub "THEAD|TFOOT|TBODY" $content "" ""]} {lappend err "$tag must appear before THEAD, TFOOT, and TBODY inside TABLE."}
  526.         }
  527.         THEAD {
  528.             if {[regsub -all "THEAD" $content "" ""] > 1} {lappend err "TABLE may only contain one THEAD element."}
  529.             if {[regsub "TFOOT|TBODY" $content "" ""]} {lappend err "THEAD must appear before TFOOT and TBODY inside TABLE."}
  530.         }
  531.         TFOOT {
  532.             if {[regsub -all "TFOOT" $content "" ""] > 1} {lappend err "TABLE may only contain one TFOOT element."}
  533.             if {[regsub "TBODY" $content "" ""]} {lappend err "TFOOT must appear before TBODY inside TABLE."}
  534.         }
  535.     }
  536. }
  537.  
  538. proc html::MustContainCheckTBODY {content e} {
  539.     upvar $e err
  540.     if {$content == ""} {lappend err "TBODY must contain at least one TR element."}
  541. }
  542.  
  543. proc html::MustContainCheckTHEAD {content e} {
  544.     upvar $e err
  545.     if {$content == ""} {lappend err "THEAD must contain at least one TR element."}
  546. }
  547.  
  548. proc html::MustContainCheckTFOOT {content e} {
  549.     upvar $e err
  550.     if {$content == ""} {lappend err "TFOOT must contain at least one TR element."}
  551. }
  552.  
  553. proc html::MustContainCheckTR {content e} {
  554.     upvar $e err
  555.     if {$content == ""} {lappend err "TR must contain at least one TD or TH element."}
  556. }
  557.  
  558. proc html::MustContainCheckUL {content e} {
  559.     upvar $e err
  560.     if {$content == ""} {lappend err "UL must contain at least one LI element."}
  561. }
  562.  
  563. #===============================================================================
  564. # ◊◊◊◊ Attributes ◊◊◊◊ #
  565. #===============================================================================
  566.  
  567. proc html::CheckAttributes {tag txt e pos doctype} {
  568.     upvar $e err
  569.     if {$tag == "LI"} {
  570.         html::FindList tag $pos
  571.     }
  572.     html::ExtractAttrValues $txt attrs attrVals err " of $tag"
  573.     if {$tag == "INPUT"} {
  574.         set typeIndex [lsearch -exact [string toupper $attrs] "TYPE="]
  575.         if {$typeIndex >= 0 } {
  576.             set tag [string toupper [lindex $attrVals $typeIndex]]
  577.             set tag "INPUT TYPE=${tag}"
  578.             # Remove TYPE attribute from list.
  579.             set attrs [lreplace $attrs $typeIndex $typeIndex]
  580.             set attrVals [lreplace $attrVals $typeIndex $typeIndex]
  581.         } else {
  582.             set tag "INPUT TYPE=TEXT"
  583.         } 
  584.  
  585.     } 
  586.     set req [html::GetRequired $tag]
  587.     set allAttrs [string toupper [concat $req [html::GetOptional $tag 1]]]
  588.     set exp "\[ \n\r\t]+([join [html::GetExtensions $tag] |])"
  589.     regsub -all $exp " $allAttrs" " " allAttrs
  590.     if {$doctype == "strict"} {
  591.         set exp "\[ \n\r\t]+([join [concat TARGET= [html::GetDeprecated $tag]] |])"
  592.         regsub -all $exp " $allAttrs" " " allAttrs
  593.     }
  594.     foreach a $req {
  595.         if {[lsearch -exact $attrs $a] < 0} {
  596.             lappend err "Required attribute $a of $tag missing."
  597.         }
  598.     }
  599.     for {set i 0} {$i<[llength $attrs]} {incr i} {
  600.         set a [lindex $attrs $i]
  601.         if {[lsearch -exact $allAttrs [string trim $a =]] >= 0} {
  602.             set a [string trim $a =]
  603.         }
  604.         if {[lsearch -exact $allAttrs $a] < 0} {
  605.             lappend err "Unknown attribute [lindex $attrs $i] of $tag."
  606.             continue
  607.         }
  608.         set attrType [html::GetAttrType $tag $a]
  609.         if {[info commands html::CheckAttribute$attrType] != "" || [info commands ::html::CheckAttribute$attrType] != ""} {
  610.             html::CheckAttribute$attrType $tag $a [string trim [lindex $attrVals $i]] err
  611.         }
  612.     }
  613.     
  614. }
  615.  
  616. # flag
  617. proc html::CheckAttributeflag {tag attr val e} {
  618.     upvar $e err
  619.     if {$val != "1" && [string toupper $val] != $attr} {
  620.         lappend err "$tag $attr=\"$val\": Incorrect value."
  621.     }
  622. }
  623.  
  624. # color
  625. proc html::CheckAttributecolor {tag attr val e} {
  626.     upvar $e err
  627.     if {[html::CheckColorNumber $val] == 0} {
  628.         lappend err "$tag $attr\"$val\": Invalid color number."
  629.     }
  630. }
  631.  
  632. # choices 
  633. proc html::CheckAttributechoices {tag attr val e} {
  634.     upvar $e err
  635.     if {[lsearch -exact [html::GetAttrChoices $tag $attr] [string toupper $val]] < 0} {
  636.         lappend err "$tag $attr\"$val\": Unknown choice."
  637.     }
  638. }
  639.  
  640. # length
  641. proc html::CheckAttributelength {tag attr val e} {
  642.     upvar $e err
  643.     if {[set res [html::CheckAttrNumber $tag $attr $val 1]] != 1} {
  644.         lappend err "$tag $attr\"$val\": $res"
  645.     }
  646. }
  647.  
  648. # integer
  649. proc html::CheckAttributeinteger {tag attr val e} {
  650.     upvar $e err
  651.     if {[set res [html::CheckAttrNumber $tag $attr $val 0]] != 1} {
  652.         lappend err "$tag $attr\"$val\": $res"
  653.     }
  654. }
  655.  
  656. #id 
  657. proc html::CheckAttributeid {tag attr val e} {
  658.     upvar $e err
  659.     if {![html::CheckId $val]} {
  660.         lappend err "$tag $attr\"$val\": Value must begin with a letter and only containg letters, digits, and '_' '-' ':' '.'"
  661.     }        
  662. }
  663.  
  664. #ids 
  665. proc html::CheckAttributeids {tag attr val e} {
  666.     upvar $e err
  667.     if {![html::CheckIds $val]} {
  668.         lappend err "$tag $attr\"$val\": Value must be a list of words beginning with a letter and only containg letters, digits, and '_' '-' ':' '.'"
  669.     }        
  670. }
  671.  
  672. # multilength
  673. proc html::CheckAttributemultilength {tag attr val e} {
  674.     upvar $e err
  675.     if {[set res [html::CheckAttrNumber $tag $attr $val 1 1]] != 1} {
  676.         lappend err "$tag $attr\"$val\": $res"
  677.     }
  678. }
  679.  
  680. # multilengths
  681. proc html::CheckAttributemultilengths {tag attr val e {multilength 1}} {
  682.     upvar $e err
  683.     foreach l [split $val ,] {
  684.         set l [string trim $l]
  685.         set numcheck [html::CheckAttrNumber $tag $attr $l 1 $multilength]
  686.         if {$numcheck != 1} {
  687.             lappend err "$tag $attr\"$val\": $numcheck"
  688.             break
  689.         }
  690.     }
  691. }
  692.  
  693. # coords
  694. proc html::CheckAttributecoords {tag attr val e} {
  695.     upvar $e err
  696.     foreach l [split $val ,] {
  697.         set l [string trim $l]
  698.         set numcheck [html::CheckAttrNumber $tag $attr $l 1 0]
  699.         if {$numcheck != 1} {
  700.             lappend err "$tag $attr\"$val\": $numcheck"
  701.             break
  702.         }
  703.     }
  704. }
  705.  
  706. # oltype
  707. proc html::CheckAttributeoltype {tag attr val e} {
  708.     upvar $e err
  709.     if {[lsearch -exact [html::GetAttrChoices $tag $attr] $val] < 0} {
  710.         lappend err "$tag $attr\"$val\": Unknown choice."
  711.     }
  712. }
  713.  
  714. # character
  715. proc html::CheckAttributecharacter {tag attr val e} {
  716.     upvar $e err
  717.     if {[string length $val] != 1} {
  718.         lappend err "$tag $attr\"$val\": Only a single character is allowed."
  719.     }
  720. }
  721.  
  722. # datetime
  723. proc html::CheckAttributedatetime {tag attr val e} {
  724.     upvar $e err
  725.     if {[regexp {^([0-9]+)-([0-9]+)-([0-9]+)T([0-9]+):([0-9]+):([0-9]+)(Z|[-+][0-9]+:[0-9]+)$} $val "" Y M D h m s tzd]} {
  726.         if {[catch {html::CheckDateTime [list $Y $M $D $h $m $s $tzd]} res]} {
  727.             lappend err "$tag $attr\"$val\": $res"
  728.         }
  729.     } else {
  730.         lappend err "$tag $attr\"$val\": Incorrect date and time."
  731.     }
  732. }
  733.  
  734. #===============================================================================
  735. # ◊◊◊◊ Specification ◊◊◊◊ #
  736. #===============================================================================
  737.  
  738. set _headmisc {SCRIPT STYLE META LINK OBJECT}
  739. set _headContent {TITLE ISINDEX BASE}
  740. set _heading {H1 H2 H3 H4 H5 H6}
  741. set _lists {UL OL DIR MENU}
  742. set _preformatted {PRE}
  743. set _fontstyle {TT I B U S STRIKE BIG SMALL}
  744. set _phrase {EM STRONG DFN CODE SAMP KBD VAR CITE ABBR ACRONYM}
  745. set _special {A IMG APPLET OBJECT FONT BASEFONT BR SCRIPT MAP Q SUB SUP SPAN BDO IFRAME}
  746. set _formctrl {INPUT SELECT TEXTAREA LABEL BUTTON}
  747. set _inline [concat text $_fontstyle $_phrase $_special $_formctrl]
  748. set _block [concat P $_heading $_lists $_preformatted DL DIV CENTER NOSCRIPT NOFRAMES BLOCKQUOTE FORM ISINDEX HR TABLE FIELDSET ADDRESS]
  749. set _flow [concat $_inline $_block]
  750.  
  751. # Empty elements
  752. set html::EmptyElems {BASEFONT BR AREA LINK IMG PARAM HR INPUT COL FRAME ISINDEX BASE META}
  753.  
  754. # Tags with restricted nesting
  755. set html::NestRestrictTags [concat $_formctrl $_block A LABEL IFRAME IMG OBJECT APPLET BIG SMALL SUB SUP FONT BASEFONT STYLE META LINK INS DEL]
  756.  
  757. foreach i {IMG OBJECT APPLET BIG SMALL SUB SUP FONT BASEFONT} {
  758.     set html::NestingRestriction($i) PRE
  759. }
  760. foreach i [concat $_formctrl IFRAME A] {
  761.     set html::NestingRestriction($i) BUTTON
  762. }
  763. foreach i $_block {
  764.     set html::NestingRestriction($i) {DIR MENU}
  765. }
  766. foreach i {STYLE META LINK} {
  767.     set html::NestingRestriction($i) BODY
  768. }
  769. foreach i {INS DEL} {
  770.     set html::NestingRestriction($i) HEAD
  771. }
  772.  
  773. lappend html::NestingRestriction(A) A
  774. lappend html::NestingRestriction(ISINDEX) BUTTON
  775. lappend html::NestingRestriction(FIELDSET) BUTTON
  776. lappend html::NestingRestriction(LABEL) LABEL
  777. lappend html::NestingRestriction(NOFRAMES) NOFRAMES
  778. lappend html::NestingRestriction(FORM) FORM BUTTON
  779.  
  780. # Define what each element mayContain contain
  781. foreach i [concat $_fontstyle $_phrase $_heading SUB SUP SPAN BDO FONT A P PRE Q DT LABEL LEGEND CAPTION] {
  782.     set html::ElemMayContain($i) [concat $_inline INS DEL STYLE META LINK]
  783. }
  784. foreach i {DIV CENTER INS DEL DD LI BUTTON TH TD IFRAME} {
  785.     set html::ElemMayContain($i) [concat $_flow INS DEL STYLE META LINK]
  786. }
  787.  
  788. foreach i $_lists {
  789.     set html::ElemMayContain($i) LI
  790. }
  791. set html::ElemMayContainLoose(BODY) [concat $_flow INS DEL]
  792. set html::ElemMayContainStrict(BODY) [concat $_block SCRIPT INS DEL]
  793. set html::ElemMayContainFrame(BODY) [concat $_flow INS DEL]
  794. set html::ElemMayContainLoose(BLOCKQUOTE) [concat $_flow INS DEL STYLE META LINK]
  795. set html::ElemMayContainStrict(BLOCKQUOTE) [concat $_block SCRIPT INS DEL STYLE META LINK]
  796. set html::ElemMayContainFrame(BLOCKQUOTE) [concat $_flow INS DEL STYLE META LINK]
  797. set html::ElemMayContainLoose(FORM) [concat $_flow INS DEL STYLE META LINK]
  798. set html::ElemMayContainStrict(FORM) [concat $_block SCRIPT INS DEL STYLE META LINK]
  799. set html::ElemMayContainFrame(FORM) [concat $_flow INS DEL STYLE META LINK]
  800. set html::ElemMayContainLoose(ADDRESS) [concat $_inline P INS DEL STYLE META LINK]
  801. set html::ElemMayContainStrict(ADDRESS) [concat $_inline INS DEL STYLE META LINK]
  802. set html::ElemMayContainFrame(ADDRESS) [concat $_inline P INS DEL STYLE META LINK]
  803. set html::ElemMayContain(MAP) [concat $_block AREA INS DEL STYLE META LINK]
  804. set html::ElemMayContain(OBJECT) [concat $_flow PARAM INS DEL STYLE META LINK]
  805. set html::ElemMayContain(APPLET) [concat $_flow PARAM INS DEL STYLE META LINK]
  806. set html::ElemMayContain(DL) {DT DD}
  807. set html::ElemMayContain(SELECT) {OPTGROUP OPTION}
  808. set html::ElemMayContain(OPTGROUP) OPTION
  809. set html::ElemMayContain(OPTION) text
  810. set html::ElemMayContain(TEXTAREA) text
  811. set html::ElemMayContain(FIELDSET) [concat $_flow LEGEND INS DEL STYLE META LINK]
  812. set html::ElemMayContain(TABLE) {CAPTION COL COLGROUP THEAD TBODY TFOOT}
  813. set html::ElemMayContain(TBODY) TR
  814. set html::ElemMayContain(THEAD) TR
  815. set html::ElemMayContain(TFOOT) TR
  816. set html::ElemMayContain(COLGROUP) COL
  817. set html::ElemMayContain(TR) {TD TH}
  818. set html::ElemMayContain(FRAMESET) {FRAMESET FRAME NOFRAMES}
  819. set html::ElemMayContainLoose(NOFRAMES) [concat $_flow INS DEL STYLE META LINK]
  820. set html::ElemMayContainFrame(NOFRAMES) {BODY}
  821. set html::ElemMayContainLoose(NOSCRIPT) [concat $_flow INS DEL STYLE META LINK]
  822. set html::ElemMayContainStrict(NOSCRIPT) [concat $_block INS DEL STYLE META LINK]
  823. set html::ElemMayContain(HEAD) [concat $_headContent $_headmisc]
  824. set html::ElemMayContain(TITLE) text
  825. set html::ElemMayContain(STYLE) text
  826. set html::ElemMayContain(SCRIPT) text
  827. set html::ElemMayContainLoose(HTML) {HEAD BODY}
  828. set html::ElemMayContainStrict(HTML) {HEAD BODY}
  829. set html::ElemMayContainFrame(HTML) {HEAD FRAMESET}
  830.  
  831. # Dummy tag to start with.
  832. set html::ElemMayContain(WINDOW) HTML
  833.  
  834. unset _headmisc _headContent _heading _lists _preformatted _fontstyle _phrase _special _formctrl _inline _block _flow
  835.